perm filename BGEN.F4[1,MUS] blob sn#081800 filedate 1974-01-11 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	
C00004 00003		ACCEPT 201,AB
C00006 00004		IY=FUN(I)*100.
C00007 ENDMK
CāŠ—;

	SUBROUTINE GEN(FUN)
C  AFTER 'SYNTH(F1);'  TYPE 99= TO USE  H,A,P,K: ALL OTHER
C   NUMBERS = H,A ONLY.  TYPE 999 TO END. NORMALIZATION IS AUTOMATIC.
	DIMENSION FUN(100),A(512)
	COMMON FREQ(3,0/50,100),FUNC(100),AMP(100),II(1),IJJ(4000)
	TYPE 499
	ACCEPT 201,AB
	IF(AB.EQ.0)GO TO 999
4000	TYPE 500
	ACCEPT 501,FILE
	IF(LOOKD(FILE).GE.0)GO TO 4000
	CALL IFILE(1,FILE)
553	TYPE 502
	ACCEPT 501,FN
	DO 550 I=1,2
550	READ(1,501),TS1
551	READ(1,504,END=553),TS1,TS2,FK
555	IF(FN.NE.FK)GO TO 551
552	READ(1,505),TS1,TS2
556	IF(TS2.LE.100)GO TO 552
	READ(1,506),(A(K),K=1,512)
	IXCT=1
	XCT=1.0
	XINC=512./100.
	DO 560 J=1,100
	FUN(J)=A(IXCT)
	XCT=XCT+XINC
560	IXCT=XCT
	GO TO 446
499	FORMAT(' TYPE 1 FOR FUN ON DSK, ELSE CR'/)
500	FORMAT(' TYPE FILE NAME'/)
501	FORMAT(A5)
502	FORMAT(' TYPE FUNCTION NAME'/)
504	FORMAT(2(A5,A1))
505	FORMAT(2F)
506	FORMAT(8F)
999	TYPE 1002
1002	FORMAT(' CR TO CLEAR ELSE 1'/)
	ACCEPT 201,AB
	IF(AB.NE.0.0)GO TO 1001
	DO 15 I=1,100
15	FUN(I)=0.0
201	FORMAT(4F)
1001	FAC=360./100.
16	CALL DPYSET(1,IJJ,3000)
	CALL ALINE(0,0,200,0)
	CALL ALINE(0,100,0,0)
	TYPE 445
445	FORMAT(' TYPE H,A,P,K OR  CR'/)
	ACCEPT 201,H,AMPL,X,CON
	IF(H.LE.0.0)GO TO 446
	X=X*100./360.	
2016	DO 17 J=1,100
	XK=SIND(X*FAC)*AMPL+CON
	IF(CON.LT.100.0)GO TO 1
	FUN(J)=(XK-100.)*FUN(J)
	GO TO 2
1	FUN(J)=FUN(J)+XK
2	X=X+H
	IY=FUN(J)*100.
	IX=J*2
	CALL AVECT(IX,IY)
	IF(X.LE.50.)GO TO 17
	X=X-100.
17	CONTINUE
	CALL DPYOUT(1)
	GO TO 16
446	CALL DPYSET(1,IJJ,3000)
	CALL ALINE(0,0,200,0)
	CALL ALINE(0,100,0,0)
2200	X=FUN(1)
	DO 19 I=2,100
	H=ABS(FUN(I))
19	IF(X.LT.H)X=H
	DO 20 I=1,100
	FUN(I)=FUN(I)/X
	IY=FUN(I)*100.
	IX=(I-1)*2
20	CALL AVECT(IX,IY)
	CALL DPYOUT(1)
	TYPE 97
97	FORMAT(' CR TO FINISH OR 1 TO ADD MORE'/)
	ACCEPT 201,ZZZ
	IF(ZZZ.EQ.1.)GO TO 999
	CALL HYDPOG(1)
	RETURN
	END